The PC-SIG Library 10/The PC-Sig Library - Shareware for the IBM PC and Compatibles (PC-SIG)(Tenth Edition Disks 1-2804)(1991).iso/PC_SIGCD/19/8/DISK1982.ZIP/VIODEMO.PAS

Pascal/Delphi Source File | 1991-03-15 | 32KB | 1,200 lines

{--------------------------------------------------------------------}
{- Before compiling this demo program make sure the Unit Directories-}
{- in the Options, Directories menu specify where to find the       -}
{- FlashPac Units.                                                  -}
{-                                                                  -}
{- Compiler       Directory                                         -}
{- --------       -----------------                                 -}
{-  TP4           A:\TP4                                            -}
{-  TP5           A:\TP5                                            -}
{-  TP55          A:\TP55                                           -}
{-                                                                  -}
{--------------------------------------------------------------------}

program testit;
uses crt,dos,FPVideo,FPGetKey;
Type
   Str4  = String[4];
   TCell = Record
              Ch,Attr : Byte;
           End;
Var
   i,j,i1            : integer;
   k                 : Word;
   ChOfs,TE          : Integer;
   St                : String;
   H1,M1,S1,Sec100_1,
   H2,M2,S2,Sec100_2 : Word;
   t1,t2,t3,Total    : Word;
   Done              : Boolean;

Procedure ClearTime;
Begin
   H1       := 0;  H2       := 0;
   M1       := 0;  M2       := 0;
   S1       := 0;  S2       := 0;
   Sec100_1 := 0;  Sec100_2 := 0;
   Total    := 0;

End;

Function Dec_To_Hex(Number : Word) : Str4;
Const
   Digits : String[16] = '0123456789ABCDEF';
Var
   i  : Word;
   St : String[4];
Begin
   FillChar(St,SizeOf(St),0);
   For i := 4 DownTo 1 Do Begin
      St[i] := Digits[Number Mod 16 + 1];
      Number := Number Div 16;
   End;
   St[0] := Chr(4);
   Dec_To_Hex := St;
End;

Procedure DisplayTime(NTimes : Integer);
Var
   Ch  : Char;
   Tot : Real;
Begin
   Window(15,10,65,14);
   ClrWin(15,10,65,14,48);
   FrameWin('╔','╗','╚','╝','═','║',48);
   TextAttr := 48;
   Gotoxy(1,1);
   Writeln('  Total Time   = ',Total:1);
   Writeln('  NTimes       = ',NTimes:1);
   Tot := Total / NTimes;
   Write('  Average time = ',Tot:7:4,' hundredths of a second');
   ColorMsg(18,14,144,' Press any key to continue... ');
   Ch := ReadKey;
   TextAttr := 7;
End;

Procedure TestBorderColor;
Var
   i  : Integer;
   Ch : Char;
Begin
   If VioMode = 7 Then Begin
         ClrWin(1,1,80,25,7);
         Window(21,11,60,14);
         ClrWin(21,11,60,14,48);
         FrameWin('╔','╗','╚','╝','═','║',48);
         ColorMsg(23,12,48,'Not Available on Monochrome monitors');
         ColorMsg(23,13,48,'    Press any key to continue...');
         Window(1,1,80,25);
      End
   Else Begin
      For i := 1 To 15 Do Begin
         BorderColor(i);
         Writeln('Press any key to continue...');
         Ch := ReadKey;
      End;
   End;
   Ch := ReadKey;
   BorderColor(0);
End;

Procedure TestClrWin;
Var
   Color,TopRow,BottomRow,LeftCol,RightCol : Integer;
   Ch                                      : Char;
Begin
   ClrWin(1,1,80,25,7);
   Gotoxy(1,1);
   Write('Enter attribute value to clear screen with. 0-255 ==> ');
   Readln(Color);
   Write('Enter top row of area to clear. 1-25 ==> ');
   Readln(TopRow);
   Write('Enter left column of area to clear.  1-80 ==> ');
   Readln(LeftCol);
   Write('Enter bottom row of area to clear. ',TopRow:1,'-25 ==> ');
   Readln(BottomRow);
   Write('Enter right column of area to clear.  ',LeftCol:1,'-80 ==> ');
   Readln(RightCol);
   FillRowCell(1,1,2000,(65 shl 8) + 7);
   ColorMsg(1,1,48,'Press any key to clear area');
   Ch := ReadKey;
   ClrWin(LeftCol,TopRow,RightCol,BottomRow,Color);
   ColorMsg(1,1,48,'Press any key to return to menu');
   Ch := ReadKey;
End;

Procedure TestColorMsg;
Var
   Msg   : String;
   Ch    : Char;
   Color : Integer;
Begin
   TextAttr := 7;
   Repeat
      ClrWin(1,1,80,25,7);
      Gotoxy(1,1);
      Window(10,1,69,3);
      FrameWin('╔','╗','╚','╝','═','║',TextAttr);
      ColorMsg(12,2,TextAttr,'Enter "QUIT" for message when you ' +
                             'want to quit this test');
      Window(1,4,60,7);
      FrameWin('╔','╗','╚','╝','═','║',TextAttr);
      ColorMsg(3,4,TextAttr,' ColorMsg data ');
      ColorMsg(3,5,TextAttr,'Enter message to display ==> ');
      Gotoxy(31,1);
      Readln(Msg);
      ColorMsg(3,6,TextAttr,'Enter the color to display message in ==> ');
      Gotoxy(44,2);
      Readln(Color);

      Window(1,10,50,14);
      FrameWin('╔','╗','╚','╝','═','║',TextAttr);
      ColorMsg(3,11,Color,Msg);
      TextAttr := RvsAttr(TextAttr);
      ColorMsg(2,13,TextAttr,'          ' +
                             'Press any key to continue...          ');
      TextAttr := RvsAttr(TextAttr);
      Ch := ReadKey;
      For Color := 1 To 4 Do
         Msg[Color] := UpCase(Msg[Color]);
   Until Msg = 'QUIT'
End;

Procedure TestEditSt;
Const
   TCSet : TSet = [13];
   VCSet : TSet = [32,65..122];
Var
   Ch          : Char;
   Char_Ofs,TE : Integer;
   St          : String;
Begin
   ClrWin(1,1,80,25,7);
   ColorMsg(1,10,7,'Enter your name:');
   St       := '';
   Char_Ofs := 1;
   TE       := 0;
   FillChar(St,SizeOf(St),0);
   EditSt(10,18,28,30,1,7,0,7000,2000,VCSet,TCSet,Char_Ofs,TE,St);
   GotoxyAbs(1,15);
   WriteLn('*',St,'*','  len = ',Length(St):1 );
   TextAttr := RvsAttr(TextAttr);
   Ch := ReadKey;
End;

Procedure TestFillColAttr;
Const
   NTimes = 80;
Var
   i : Integer;

Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      GetTime(H1,M1,S1,Sec100_1);
      FillColAttr(i,1,25,i*16);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestFillColCell;
Const
   NTimes = 80;
Var
   i      : Word;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      GetTime(H1,M1,S1,Sec100_1);
      FillColCell(i,1,25,((i+64) shl 8) + i);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestFillColChar;
Const
   NTimes = 80;
Var
   i      : Integer;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      GetTime(H1,M1,S1,Sec100_1);
      FillColChar(i,1,25,Chr(i+64));
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestFillFrameAttr;
Const
   NTimes = 15;
Var
   i      : Integer;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      GetTime(H1,M1,S1,Sec100_1);
      FillFrameAttr(1,1,80,25,i*16);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestFillFrameCell;
Const
   NTimes = 15;
Var
   i      : Integer;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      GetTime(H1,M1,S1,Sec100_1);
      FillFrameCell(1,1,80,25,((i+64) shl 8) + i);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestFillFrameChar;
Const
   NTimes = 15;
Var
   i      : Integer;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      GetTime(H1,M1,S1,Sec100_1);
      FillFrameChar(1,1,80,25,Chr(i+64));
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestFillRowAttr;
Const
   NTimes = 15;
Var
   i      : Integer;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      GetTime(H1,M1,S1,Sec100_1);
      FillRowAttr(1,1,2000,i*16);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestFillRowCell;
Const
   NTimes = 15;
Var
   i      : Integer;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      GetTime(H1,M1,S1,Sec100_1);
      FillRowCell(1,1,2000,((64+i) shl 8) + i);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestFillRowChar;
Const
   NTimes = 15;
Var
   i      : Integer;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      GetTime(H1,M1,S1,Sec100_1);
      FillRowChar(1,1,2000,Chr(i+64));
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestGetFrameAttr;
Const
   NTimes = 15;
Var
   i      : Integer;
   Buffer : Array[1..25,1..80] Of Byte;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin
      FillRowCell(1,1,2000,((i+64) shl 8) + i*16);

      GetTime(H1,M1,S1,Sec100_1);
      GetFrameAttr(1,1,80,25,Buffer);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestGetFrameCell;
Const
   NTimes = 15;
Var
   i      : Integer;
   Buffer : Array[1..25,1..80] Of TCell;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin
      FillRowCell(1,1,2000,((i+64) shl 8) + i*16);

      GetTime(H1,M1,S1,Sec100_1);
      GetFrameCell(1,1,80,25,Buffer);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestGetFrameChar;
Const
   NTimes = 15;
Var
   i      : Integer;
   Buffer : Array[1..25,1..80] Of Char;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin
      FillRowCell(1,1,2000,((i+64) shl 8) + i*16);

      GetTime(H1,M1,S1,Sec100_1);
      GetFrameChar(1,1,80,25,Buffer);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestGetScrn;
Const
   NTimes = 30;
Var
   i      : Integer;
   Buffer : Array[1..25,1..80] Of TCell;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      FillRowChar(1,1,2000,Chr(i+64));
      GetTime(H1,M1,S1,Sec100_1);
      GetScrn(1,1,2000,Buffer);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);

End;

Procedure TestPutScrn;
Const
   NTimes = 30;
Var
   i      : Integer;
   Buffer : Array[1..25,1..80] Of TCell;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      FillRowChar(1,1,2000,Chr(i+64));
      GetScrn(1,1,2000,Buffer);
      FillRowChar(1,1,2000,Chr(0));

      GetTime(H1,M1,S1,Sec100_1);
      PutScrn(1,1,2000,Buffer);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestPutFrameAttr;
Const
   NTimes = 15;
Var
   i      : Integer;
   Buffer : Array[1..25,1..80] Of Byte;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin
      FillRowCell(1,1,2000,((i+64) shl 8) + i*16);
      GetFrameAttr(1,1,80,25,Buffer);
      ClrWin(1,1,80,25,7);

      GetTime(H1,M1,S1,Sec100_1);
      PutFrameAttr(1,1,80,25,Buffer);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestPutFrameCell;
Const
   NTimes = 15;
Var
   i      : Integer;
   Buffer : Array[1..25,1..80] Of TCell;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin
      FillRowCell(1,1,2000,((i+64) shl 8) + i);
      GetFrameCell(1,1,80,25,Buffer);

      ClrWin(1,1,80,25,7);
      GetTime(H1,M1,S1,Sec100_1);
      PutFrameCell(1,1,80,25,Buffer);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestPutFrameChar;
Const
   NTimes = 15;
Var
   i      : Integer;
   Buffer : Array[1..25,1..80] Of Char;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin
      FillRowCell(1,1,2000,((i+64) shl 8) + i*16);
      GetFrameChar(1,1,80,25,Buffer);
      ClrWin(1,1,80,25,7);

      GetTime(H1,M1,S1,Sec100_1);
      PutFrameChar(1,1,80,25,Buffer);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;


Procedure TestGetCursorSize;
Var
   Ch : Char;
Begin
   ClrWin(1,1,80,25,7);
   Window(24,10,55,14);
   ClrWin(24,10,55,14,48);
   FrameWin('╔','╗','╚','╝','═','║',48);
   Gotoxy(1,1);
   TextAttr := 48;
   ColorMsg(26,10,48,' GetCursorSize ');
   Writeln(' Starting scan line = ',Hi(VioCursor):1);
   Writeln(' Ending scan line   = ',Lo(VioCursor):1);
   Write(' Press any key to continue...');
   Ch := ReadKey;
   TextAttr := 7;
End;

Procedure TestSetCursorSize;
Var
   Ch            : Char;
   StScan,SpScan : Integer;
Begin
   ClrWin(1,1,80,25,7);
   Window(24,10,57,14);
   ClrWin(24,10,57,14,48);
   FrameWin('╔','╗','╚','╝','═','║',48);
   Gotoxy(1,1);
   TextAttr := 48;
   ColorMsg(26,10,48,' GetCursorSize ');
   Write(' Enter Starting scan line = ');
   Readln(StScan);
   Write(' Ending scan line   = ');
   Readln(SpScan);
   SetCursorSize(StScan,SpScan);
   Write(' Press any key to continue...');
   Ch := ReadKey;
   TextAttr := 7;
End;

Procedure TestFrameWin;
Const
   NTimes = 12;
Var
   i      : Integer;
   tot    : Real;
   Ch     : Char;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   Window(1,1,80,25);
   For i := 1 To NTimes Do Begin
{      Window(i,i,80,25);        }
      GetTime(H1,M1,S1,Sec100_1);
      FrameWin('┌','┐','└','┘','─','│',7);
      GetTime(H2,M2,S2,Sec100_2);

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestRvsAttr;
Var
   St    : String;
   Ch    : Char;
   i,j,k : Integer;
   HiCur,LoCur : Integer;
begin
   HiCur := Hi(VioCursor);
   LoCur := Lo(VioCursor);
   SetCursorSize(32,32);
   ClrWin(1,1,80,25,7);

   Window(5,2,40,19);
   FrameWin('╔','╗','╚','╝','═','║',7);
   ColorMsg(7,2,7,' Text with normal attributes ');

   Window(45,2,80,19);
   FrameWin('╔','╗','╚','╝','═','║',7);
   ColorMsg(47,2,7,' Text with reverse attributes ');

   k := 0;
   For j := 1 To 16 Do Begin
      ClrWin(6,3,39,18,7);
      ClrWin(46,3,79,18,7);
      For i := 0 To 15 Do Begin

         TextAttr := k;
         Str(TextAttr:3,St);
         ColorMsg( 6,i+3,TextAttr,'        TextAttr = '+St+'            ');

         TextAttr := RvsAttr(TextAttr);
         Str(TextAttr:3,St);
         ColorMsg(46,i+3,TextAttr,'       TextAttr = '+St+'             ');
         k := k + 1;
      End;
      Window(25,22,56,24);
      FrameWin('╔','╗','╚','╝','═','║',7);
      ColorMsg(26,23,144,' Press any key to continue... ');
      Ch := ReadKey;
      ClrWin(25,22,56,24,7);
      Delay(200);
   End;
   TextAttr := 6;
   SetCursorSize(LoCur,HiCur);
End;

Procedure TestGetVideoMode;
Var
   Ch : Char;
   St : String;
Begin
   ClrWin(1,1,80,25,7);
   Window(20,11,60,13);
   FrameWin('╔','╗','╚','╝','═','║',7);
   Case GetVideoMode Of
      0 : St := '0 - CGA - Text b/w Medium resolution';
      1 : St := '1 - CGA - Text color Medium resolution';
      2 : St := '2 - CGA - Text b/w High resolution';
      3 : St := '3 - CGA - Text color High resolution';
      7 : St := '7 - Monochrome monitor';
   End;

   ColorMsg(22,11,TextAttr,' Current video mode ');
   ColorMsg(22,12,TextAttr,St);
   ColorMsg(25,24,TextAttr,'Press any key to continue...');
   Ch := ReadKey;
End;

Procedure TestInitVideo;
Var
   Ch        : Char;
   OldMode,
   NewMode,i : Integer;
   St        : String;
   Error     : Boolean;
Begin
   OldMode := GetVideoMode;
   Repeat
      InitVideo(OldMode);
      ClrWin(1,1,80,25,7);
      Window(10,1,60,20);
      FrameWin('╔','╗','╚','╝','═','║',7);
      ColorMsg(12,1,TextAttr,' SetVideoMode ');
      ColorMsg(12,2,TextAttr,' 0 - CGA - Text b/w Medium resolution');
      ColorMsg(12,3,TextAttr,' 1 - CGA - Text color Medium resolution');
      ColorMsg(12,4,TextAttr,' 2 - CGA - Text b/w High resolution');
      ColorMsg(12,5,TextAttr,' 3 - CGA - Text color High resolution');
      ColorMsg(12,6,TextAttr,' 4 - CGA - Graphics Medium resolution');
      ColorMsg(12,7,TextAttr,' 5 - CGA - Graphics Medium resolution');
      ColorMsg(12,8,TextAttr,' 6 - CGA - Graphics High resolution');
      ColorMsg(12,9,TextAttr,' 7 - Monochrome monitor');
      ColorMsg(12,10,TextAttr,' 8 - PCjr - Graphics Low resolution');
      ColorMsg(12,11,TextAttr,' 9 - PCjr - Graphics Medium resolution');
      ColorMsg(12,12,TextAttr,'10 - PCjr,EGA - Graphics High resolution');
      ColorMsg(12,13,TextAttr,'13 - EGA - Graphics Medium resolution');
      ColorMsg(12,14,TextAttr,'14 - EGA - Graphics High resolution');
      ColorMsg(12,15,TextAttr,'15 - EGA - Graphics Extra high resolution');
      ColorMsg(12,16,TextAttr,'16 - Quit');
      ColorMsg(12,18,TextAttr,'Select mode to initialize ==> ');
      GotoxyAbs(42,18);
      Readln(NewMode);
      ClrWin(1,1,80,25,7);

      Error := False;
      If OldMode = 7 Then Begin
            If (NewMode <> 7) And (NewMode <> 16) Then
               Error := True;
         End
      Else If NewMode In [8..10] Then
         Error := True
      Else If NewMode > 16 Then
         Error := True;

      If Error Then Begin
            Write(#7);
            ColorMsg(1,19,TextAttr,'Invalid mode was entered.  '+
                                   'Press any key to continue');
            Ch := ReadKey;
         End
      Else If NewMode <> 16 Then Begin
         ClrWin(1,1,80,25,7);
         InitVideo(NewMode);
         If NewMode In [4,5,6,8,9,10,13,14,15] Then
            DirectVideo := False;
         For i := 1 to 20 Do
            Writeln('This is the new video mode');
         Write('Press any key to continue...');
         Ch := ReadKey;
         DirectVideo := True;
      End;

   Until NewMode = 16;
End;

Procedure TestGetVideoCols;
Var
   Ch : Char;
   St : String;
Begin
   ClrWin(1,1,80,25,7);
   Window(24,10,57,13);
   ClrWin(24,10,57,13,48);
   FrameWin('╔','╗','╚','╝','═','║',48);
   Gotoxy(1,1);
   TextAttr := 48;
   ColorMsg(26,10,48,' GetVideoCols ');
   Str(GetVideoCols:1,St);
   WriteLn(' Number of columns = ' + St);
   Write(' Press any key to continue...');
   Ch := ReadKey;
   TextAttr := 7;
End;

Procedure TestGetVideoPage;
Var
   Ch : Char;
   St : String;
Begin
   ClrWin(1,1,80,25,7);
   Window(24,10,57,13);
   ClrWin(24,10,57,13,48);
   FrameWin('╔','╗','╚','╝','═','║',48);
   ColorMsg(26,10,48,' GetVideoPage ');
   Str(GetVideoPage:1,St);
   ColorMsg(25,11,48,' Current video page number = ' + St);
   ColorMsg(25,12,48,' Press any key to continue...');
   Ch := ReadKey;
   TextAttr := 7;
End;

Procedure TestGetVideoInfo;
Var
   Ch : Char;
   St : String;
Begin
   ClrWin(1,1,80,25,7);
   Window(24,9,57,17);
   ClrWin(24,9,57,17,48);
   FrameWin('╔','╗','╚','╝','═','║',48);
   ColorMsg(26,9,48,' GetVideoInfo ');

   Str(GetVideoMode:1,St);
   ColorMsg(25,10,48,' Current mode         = ' + St);

   Str(GetVideoPage:1,St);
   ColorMsg(25,11,48,' Active page          = ' + St);

   Str(GetVideoCols:1,St);
   ColorMsg(25,12,48,' Number cols          = ' + St);

   St := Dec_To_Hex(VioBaseSeg);
   ColorMsg(25,13,48,' Base Segment Address = ' + St);

   ColorMsg(25,16,48,' Press any key to continue...');
   Ch := ReadKey;
End;

Procedure TestSetVideoPage;
Var
   Ch   : Char;
   St   : String;
   PgNo : Integer;
Begin
   ClrWin(1,1,80,25,7);
   Window(24,8,57,17);
   ClrWin(24,8,57,17,48);
   FrameWin('╔','╗','╚','╝','═','║',48);
   GotoxyAbs(25,10);
   ColorMsg(26,8,48,' SetVideoPage ');
   Str(GetVideoPage:1,St);
   ColorMsg(25,9,48,' Current video page number = ' + St);
   If VioMode In [0..3] Then Begin
         Repeat
            ColorMsg(25,10,48,' Enter new page number ==> ');
            GotoxyAbs(53,10);
            Readln(PgNo);
         Until PgNo In [0..3];
         SetVideoPage(PgNo);
         GotoxyAbs(1,1);
      End
   Else If VioMode = 7 Then Begin
      ClrWin(25,9,56,16,48);
      ColorMsg(25,11,48,' This is the only page allowed ');
      ColorMsg(25,12,48,' for a Monochrome monitor ');
      ColorMsg(25,14,48,'Press any key to continue...');
      Ch := ReadKey;
   End;
End;

Procedure TestWhereXYAbs;
Var
   Ch      : char;
   St      : String;
   Row,Col : Integer;
Begin
   ClrWin(1,1,80,25,7);
   FillColChar(1,1,25,'+');
   FillRowCell(1,3,80,(Ord('-') Shl 8)+48);
   Col := 5;
   While Col <= 80 Do Begin
      FillRowChar(Col,3,1,'+');
      Col := Col + 5;
   End;
   ColorMsg(5,6,Textattr, 'Press one of the following keys ');
   ColorMsg(5,7,Textattr, 'to move the cursor:');
   ColorMsg(5,8,Textattr, '    U - move cursor up one line');
   ColorMsg(5,9,Textattr, '    D - move cursor down one line');
   ColorMsg(5,10,Textattr,'    R - move cursor right one column');
   ColorMsg(5,11,Textattr,'    L - move cursor left one column');
   ColorMsg(5,12,Textattr,'   <ENTER> - to return to menu');
   row := 12;
   col := 40;
   Repeat
      GotoxyAbs(col,row);

      Str(WhereXAbs:2,St);
      ColorMsg(1,1,TextAttr,'WhereXAbs = ' + St);

      Str(WhereYAbs:2,St);
      ColorMsg(1,2,TextAttr,'WhereYAbs = ' + St);

      Ch := UpCase(ReadKey);
      Case Ch Of
         'U' : Begin
                  row := row - 1;
                  If row < 1 Then
                     row := 25;
               End;
         'D' : Begin
                  row := row + 1;
                  if row > 25 then
                     row := 1;
               end;
         'L' : begin
                  col := col - 1;
                  if col < 1 then
                     col := 80;
               end;
         'R' : begin
                  col := col + 1;
                  if col > 80 then
                     col := 1;
               end;
      End;
   until ch = Chr(13);
End;

Procedure TestScrollLeft;
Const
   NTimes = 15;
Var
   Ch  : Char;
   i,j : Word;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      For j := 1 To 80 Do
         FillColCell(j,1,25,((64+j) shl 8) + j);
      Ch := ReadKey;

      GetTime(H1,M1,S1,Sec100_1);
      ScrollLeft(1,1,80,25,TextAttr,i);
      GetTime(H2,M2,S2,Sec100_2);

      Ch := ReadKey;

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestScrollRight;
Const
   NTimes = 15;
Var
   Ch  : Char;
   i,j : Word;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To NTimes Do Begin

      For j := 1 To 80 Do
         FillColCell(j,1,25,((64+j) shl 8) + j);
      Ch := ReadKey;

      GetTime(H1,M1,S1,Sec100_1);
      ScrollRight(1,1,80,25,TextAttr,i);
      GetTime(H2,M2,S2,Sec100_2);

      Ch := ReadKey;

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
End;

Procedure TestScrollDown;
Const
   NTimes = 15;
Var
   Ch     : Char;
   i,j    : Word;
   Buffer : Array[1..25,1..80] Of TCell;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To 25 Do Begin
      FillChar( Buffer[i,1], 160, i+64 );
      For j := 1 To 80 Do
         Buffer[i,j].Attr := i;
   End;
   For i := 1 To NTimes Do Begin

      PutScrn( 1, 1, 2000, Buffer );
      Ch := ReadKey;

      GetTime(H1,M1,S1,Sec100_1);
      ScrollDown(1,1,80,25,TextAttr,i);
      GetTime(H2,M2,S2,Sec100_2);

      Ch := ReadKey;

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestScrollUp;
Const
   NTimes = 15;
Var
   Ch     : Char;
   i,j    : Word;
   Buffer : Array[1..25,1..80] Of TCell;
Begin
   ClrWin(1,1,80,25,7);
   ClearTime;
   For i := 1 To 25 Do Begin
      FillChar( Buffer[i,1], 160, i+64 );
      For j := 1 To 80 Do
         Buffer[i,j].Attr := i;
   End;

   For i := 1 To NTimes Do Begin

      PutScrn( 1, 1, 2000, Buffer );
      Ch := ReadKey;

      GetTime(H1,M1,S1,Sec100_1);
      ScrollUp(1,1,80,25,TextAttr,i);
      GetTime(H2,M2,S2,Sec100_2);

      Ch := ReadKey;

      If (Sec100_2 > Sec100_1) Or ((S1 = S2) And (Sec100_1 = Sec100_2)) Then
         Total := Total + (Sec100_2 - Sec100_1)
      Else begin
         t1 := 100 - Sec100_1 + Sec100_2;
         Total := Total + t1;
      End;
   End;
   DisplayTime(NTimes);
End;

Procedure TestWriteSt;
Var
   Ch : Char;
   i  : Integer;
Begin
   ClrWin(1,1,80,25,7);
   GotoxyAbs(1,1);
   for i := 1 to 80 do
      WriteSt('This is a test...');
   ch := readkey;
End;

Procedure TestWriteStLn;
var
   i : integer;
   ch : char;
Begin
   ClrWin(1,1,80,25,7);
   GotoxyAbs(1,1);
   for i := 1 to 24 do begin
      WriteStLn('This is a test...');
   end;
   ch := readkey;
End;

Function GetMenuSelection : Integer;
Var
   Item : integer;
Begin
   Item := 0;
   TextAttr := 7;
   Repeat
      ClrWin(1,1,80,25,7);
      Window(1,1,80,25);
      GotoxyAbs(1,1);
      WriteStLn(' ');
      WriteStln(' 1. BorderColor       2. ClrWin             3. ColorMsg');
      WriteStln(' 4. EditSt');
      WriteStln(' 5. FillColAttr       6. FillColCell        7. FillColChar');
      WriteStln(' 8. FillFrameAttr     9. FillFrameCell     10. FillFrameChar');
      WriteStln('11. FillRowAttr      12. FillRowCell       13. FillRowChar');
      WriteStln('14. GetFrameAttr     15. GetFrameCell      16. GetFrameChar');
      WriteStln('17. GetScrn          18. PutScrn');
      WriteStln('19. PutFrameAttr     20. PutFrameCell      21. PutFrameChar');
      WriteStln('22. GetCursorSize    23. SetCursorSize     24. FrameWin');
      WriteStln('25. RvsAttr          26. GetVideoMode      27. GetVideoCols');
      WriteStln('28. GetVideoPage     29. GetVideoInfo      30. InitVideo');
      WriteStln('31. SetVideoPage     32. GotoxyAbs');
      WriteStln('33. WhereXAbs        34. WhereYAbs');
      WriteStln('35. ScrollLeft       36. ScrollRight');
      WriteStln('37. ScrollDown       38. ScrollUp');
      WriteStln('39. WriteSt          40. WriteStLn');
      WriteStln('41. Quit');
      WriteStln(' ');
      WriteSt('Enter selection to test ==> ');
      Readln(Item);
   Until Item In [1..41];
   GetMenuSelection := Item;
End;

begin
   DirectVideo := False;
   ClrWin(1,1,80,25,7);
   GotoxyAbs(1,1);
   Done := False;
   While Not Done Do Begin
      Case GetMenuSelection Of
          1 : TestBorderColor;        2 : TestClrWin;
          3 : TestColorMsg;           4 : TestEditSt;
          5 : TestFillColAttr;        6 : TestFillColCell;
          7 : TestFillColChar;        8 : TestFillFrameAttr;
          9 : TestFillFrameCell;     10 : TestFillFrameChar;
         11 : TestFillRowAttr;       12 : TestFillRowCell;
         13 : TestFillRowChar;       14 : TestGetFrameAttr;
         15 : TestGetFrameCell;      16 : TestGetFrameChar;
         17 : TestGetScrn;           18 : TestPutScrn;
         19 : TestPutFrameAttr;      20 : TestPutFrameCell;
         21 : TestPutFrameChar;      22 : TestGetCursorSize;
         23 : TestSetCursorSize;     24 : TestFrameWin;
         25 : TestRvsAttr;           26 : TestGetVideoMode;
         27 : TestGetVideoCols;      28 : TestGetVideoPage;
         29 : TestGetVideoInfo;      30 : TestInitVideo;
         31 : TestSetVideoPage;      32 : TestWhereXYAbs;
         33 : TestWhereXYAbs;        34 : TestWhereXYAbs;
         35 : TestScrollLeft;        36 : TestScrollRight;
         37 : TestScrollDown;        38 : TestScrollUp;
         39 : TestWriteSt;           40 : TestWriteStLn;
         41 : Done := True;
      End;
   End;
End.